{-# OPTIONS -Wall #-}

--------------------------------------------------------------------------------
-- |
-- Module      :  OchreLang.OrchSpec
-- Copyright   :  (c) Stephen Tetley 2014
-- License     :  BSD3
--
-- Maintainer  :  stephen.tetley@gmail.com
-- Stability   :  unstable
-- Portability :  GHC
--
-- Orchestra definition including late binding of pfields, etc.
--
--------------------------------------------------------------------------------

module OchreLang.OrchSpec
  (

    OrchSpec(..)
  , InstrInstance(..)
  , InitDecl(..)
  , Expr(..)
  , Literal(..)



  -- * Pretty print
  , ppOrchSpec
  , ppInstrInstance
  , ppInitDecl
  , ppExpr
  , ppLiteral


  -- * s-expression print
  , seOrchSpec
  , seInstrInstance
  , seInitDecl
  , seExpr
  , seLiteral

  -- * Utils
  , extractInstances

  ) where


import OchreLang.SyntaxBase
import OchreLang.Utils

import Text.PrettyExprHPJ                       -- package: pretty-expr-hpj
import Text.PrettyExprHPJ.Haskell98

import Text.PrettyPrint.HughesPJ                -- package: pretty

import Data.List ( sortBy )



--------------------------------------------------------------------------------
-- 





-- | At some point the orch spec will provide arglists for the 
-- instruments it defines, arglists will generate pfield 
-- assignments and close free variables.
--
data OrchSpec = OrchSpec [InstrInstance]
  deriving (Eq,Show)



data InstrInstance = InstrInstance 
      { instance_number         :: Int 
      , instance_instr_name     :: Ident
      , instance_init_decls     :: [InitDecl]
      }
  deriving (Eq,Show)


data InitDecl = InitDecl Ident Expr
  deriving (Eq,Show)


-- | Expressions are pure. 
--
-- Differences with top-syntax: no tuple type, adds Pfield type.
--
-- Applications are builtin Csound (pure) functions like abs.
--
-- 
data Expr = Lit     Literal
          | Var     Ident
          | Pfield  Int
          | App     Ident     [Expr]
          | Cond    Expr      Expr      Expr
          | UnaryE  UnaryOp   Expr
          | BinE    BinOp     Expr      Expr
          | RelE    RelOp     Expr      Expr
  deriving (Eq,Show)




data Literal = Bool     Bool
             | Int      Int
             | Float    Decimal
             | String   String
  deriving (Eq,Show)




--------------------------------------------------------------------------------
-- Pretty printing



ppOrchSpec :: OrchSpec -> Doc
ppOrchSpec (OrchSpec xs) =
    text "orch" <+> vsemiBraces (map ppInstrInstance xs)

ppInstrInstance :: InstrInstance -> Doc
ppInstrInstance (InstrInstance num name ds) =
     text "instrument" <+> int num <+> text "is" <+> ppIdent name 
                       <+> semiBraces (map ppInitDecl ds)


ppInitDecl :: InitDecl -> Doc
ppInitDecl (InitDecl vid expr) = 
   ppIdent vid <+> char '=' <+> ppExpr expr



ppExpr :: Expr -> Doc
ppExpr = unparse . exprDoc

exprDoc :: Expr -> DocE
exprDoc (Lit v)                 = Atom $ ppLiteral v
exprDoc (Var s)                 = Atom $ ppIdent s
exprDoc (Pfield i)              = Atom $ text $ 'p': show i
exprDoc (App vid es)            = Atom $ ppIdent vid <> parens (commaSep $ map ppExpr es)
exprDoc (Cond c e1 e2)          = 
    Atom $ text "cond" <+> ppExpr c <+> char '?' <+> ppExpr e1
                                    <+> char ':' <+> ppExpr e2

exprDoc (UnaryE op e)           = unaryDocE op (exprDoc e)
exprDoc (BinE op e1 e2)         = binDocE op (exprDoc e1) (exprDoc e2)
exprDoc (RelE relop e1 e2)      = relDocE relop (exprDoc e1) (exprDoc e2)


ppLiteral :: Literal -> Doc
ppLiteral (Bool b)              = text $ show b
ppLiteral (Int i)               = int i
ppLiteral (Float d)             = text $ truncatedDouble $ realToFrac d
ppLiteral (String s)            = doubleQuotes $ text s



--------------------------------------------------------------------------------
-- S-expression printing

seOrchSpec :: OrchSpec -> Doc
seOrchSpec (OrchSpec xs) = 
    seConstrV "orch" [ seElementsV $ map seInstrInstance xs ]

seInstrInstance :: InstrInstance -> Doc
seInstrInstance (InstrInstance num vid ds) =
    seConstrH "instr-instance" [ int num
                               , ppIdent vid
                               , seElementsV (map seInitDecl ds)
                               ]


seInitDecl :: InitDecl -> Doc
seInitDecl (InitDecl vid body) = 
    seConstrH "init-decl" [ ppIdent vid, seExpr body ]

seExpr :: Expr -> Doc
seExpr (Lit v)          = seLiteral v
seExpr (Var vid)        = ppIdent vid
seExpr (Pfield i)       = text $ 'p':show i
seExpr (App vid es)     = seConstrH "app" (ppIdent vid : map seExpr es)
seExpr (Cond c t f)     = seConstrV "cond" [ seExpr c, seExpr t, seExpr f ]
seExpr (UnaryE op e)    = 
    let name = text ('@':unaryOpName op) in seElementsH [name, seExpr e]

seExpr (BinE op e1 e2)  = 
    let name = text ('@':binOpName op) 
    in seElementsH [name, seExpr e1, seExpr e2]

seExpr (RelE op e1 e2)  = 
    let name = text ('@':relOpName op) 
    in seElementsH [name, seExpr e1, seExpr e2]



seLiteral :: Literal -> Doc
seLiteral (Bool b)              = text $ if b then "#t" else "#f"
seLiteral (Int i)               = int i
seLiteral (Float d)             = text $ truncatedDouble $ realToFrac d
seLiteral (String s)            = doubleQuotes $ text s


--------------------------------------------------------------------------------
-- 

extractInstances :: OrchSpec -> [InstrInstance]
extractInstances (OrchSpec xs) = sortBy fn xs
  where
    fn i1 i2 = instance_number i1 `compare` instance_number i2